home *** CD-ROM | disk | FTP | other *** search
/ PC World 2007 March / PCWorld_2007-03_cd.bin / domacnost a kancelar / scribus / scribus-1.3.3.7-win32-install.exe / tcl / tcl8.4 / msgcat1.3 / msgcat.tcl next >
Text File  |  2004-04-07  |  13KB  |  468 lines
  1. # msgcat.tcl --
  2. #
  3. #    This file defines various procedures which implement a
  4. #    message catalog facility for Tcl programs.  It should be
  5. #    loaded with the command "package require msgcat".
  6. #
  7. # Copyright (c) 1998-2000 by Ajuba Solutions.
  8. # Copyright (c) 1998 by Mark Harrison.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. # 
  13. # RCS: @(#) $Id: msgcat.tcl,v 1.17.2.3 2004/03/31 18:51:01 dgp Exp $
  14.  
  15. package require Tcl 8.2
  16. # When the version number changes, be sure to update the pkgIndex.tcl file,
  17. # and the installation directory in the Makefiles.
  18. package provide msgcat 1.3.2
  19.  
  20. namespace eval msgcat {
  21.     namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \
  22.         mcunknown
  23.  
  24.     # Records the current locale as passed to mclocale
  25.     variable Locale ""
  26.  
  27.     # Records the list of locales to search
  28.     variable Loclist {}
  29.  
  30.     # Records the mapping between source strings and translated strings.  The
  31.     # array key is of the form "<locale>,<namespace>,<src>" and the value is
  32.     # the translated string.
  33.     array set Msgs {}
  34.  
  35.     # Map of language codes used in Windows registry to those of ISO-639
  36.     array set WinRegToISO639 {
  37.         01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ
  38.               1801 ar_MA 1c01 ar_TN 2001 ar_OM 2401 ar_YE 2801 ar_SY
  39.               2c01 ar_JO 3001 ar_LB 3401 ar_KW 3801 ar_AE 3c01 ar_BH
  40.               4001 ar_QA
  41.         02 bg 0402 bg_BG
  42.         03 ca 0403 ca_ES
  43.         04 zh 0404 zh_TW 0804 zh_CN 0c04 zh_HK 1004 zh_SG 1404 zh_MO
  44.         05 cs 0405 cs_CZ
  45.         06 da 0406 da_DK
  46.         07 de 0407 de_DE 0807 de_CH 0c07 de_AT 1007 de_LU 1407 de_LI
  47.         08 el 0408 el_GR
  48.         09 en 0409 en_US 0809 en_GB 0c09 en_AU 1009 en_CA 1409 en_NZ
  49.               1809 en_IE 1c09 en_ZA 2009 en_JM 2409 en_GD 2809 en_BZ
  50.               2c09 en_TT 3009 en_ZW 3409 en_PH
  51.         0a es 040a es_ES 080a es_MX 0c0a es_ES@modern 100a es_GT 140a es_CR
  52.               180a es_PA 1c0a es_DO 200a es_VE 240a es_CO 280a es_PE
  53.               2c0a es_AR 300a es_EC 340a es_CL 380a es_UY 3c0a es_PY
  54.               400a es_BO 440a es_SV 480a es_HN 4c0a es_NI 500a es_PR
  55.         0b fi 040b fi_FI
  56.         0c fr 040c fr_FR 080c fr_BE 0c0c fr_CA 100c fr_CH 140c fr_LU
  57.               180c fr_MC
  58.         0d he 040d he_IL
  59.         0e hu 040e hu_HU
  60.         0f is 040f is_IS
  61.         10 it 0410 it_IT 0810 it_CH
  62.         11 ja 0411 ja_JP
  63.         12 ko 0412 ko_KR
  64.         13 nl 0413 nl_NL 0813 nl_BE
  65.         14 no 0414 no_NO 0814 nn_NO
  66.         15 pl 0415 pl_PL
  67.         16 pt 0416 pt_BR 0816 pt_PT
  68.         17 rm 0417 rm_CH
  69.         18 ro 0418 ro_RO
  70.         19 ru
  71.         1a hr 041a hr_HR 081a sr_YU 0c1a sr_YU@cyrillic
  72.         1b sk 041b sk_SK
  73.         1c sq 041c sq_AL
  74.         1d sv 041d sv_SE 081d sv_FI
  75.         1e th 041e th_TH
  76.         1f tr 041f tr_TR
  77.         20 ur 0420 ur_PK 0820 ur_IN
  78.         21 id 0421 id_ID
  79.         22 uk 0422 uk_UA
  80.         23 be 0423 be_BY
  81.         24 sl 0424 sl_SI
  82.         25 et 0425 et_EE
  83.         26 lv 0426 lv_LV
  84.         27 lt 0427 lt_LT
  85.         28 tg 0428 tg_TJ
  86.         29 fa 0429 fa_IR
  87.         2a vi 042a vi_VN
  88.         2b hy 042b hy_AM
  89.         2c az 042c az_AZ@latin 082c az_AZ@cyrillic
  90.         2d eu
  91.         2e wen 042e wen_DE
  92.         2f mk 042f mk_MK
  93.         30 bnt 0430 bnt_TZ
  94.         31 ts 0431 ts_ZA
  95.         33 ven 0433 ven_ZA
  96.         34 xh 0434 xh_ZA
  97.         35 zu 0435 zu_ZA
  98.         36 af 0436 af_ZA
  99.         37 ka 0437 ka_GE
  100.         38 fo 0438 fo_FO
  101.         39 hi 0439 hi_IN
  102.         3a mt 043a mt_MT
  103.         3b se 043b se_NO
  104.         043c gd_UK 083c ga_IE
  105.         3d yi 043d yi_IL
  106.         3e ms 043e ms_MY 083e ms_BN
  107.         3f kk 043f kk_KZ
  108.         40 ky 0440 ky_KG
  109.         41 sw 0441 sw_KE
  110.         42 tk 0442 tk_TM
  111.         43 uz 0443 uz_UZ@latin 0843 uz_UZ@cyrillic
  112.         44 tt 0444 tt_RU
  113.         45 bn 0445 bn_IN
  114.         46 pa 0446 pa_IN
  115.         47 gu 0447 gu_IN
  116.         48 or 0448 or_IN
  117.         49 ta
  118.         4a te 044a te_IN
  119.         4b kn 044b kn_IN
  120.         4c ml 044c ml_IN
  121.         4d as 044d as_IN
  122.         4e mr 044e mr_IN
  123.         4f sa 044f sa_IN
  124.         50 mn
  125.         51 bo 0451 bo_CN
  126.         52 cy 0452 cy_GB
  127.         53 km 0453 km_KH
  128.         54 lo 0454 lo_LA
  129.         55 my 0455 my_MM
  130.         56 gl 0456 gl_ES
  131.         57 kok 0457 kok_IN
  132.         58 mni 0458 mni_IN
  133.         59 sd
  134.         5a syr 045a syr_TR
  135.         5b si 045b si_LK
  136.         5c chr 045c chr_US
  137.         5d iu 045d iu_CA
  138.         5e am 045e am_ET
  139.         5f ber 045f ber_MA
  140.         60 ks 0460 ks_PK 0860 ks_IN
  141.         61 ne 0461 ne_NP 0861 ne_IN
  142.         62 fy 0462 fy_NL
  143.         63 ps
  144.         64 tl 0464 tl_PH
  145.         65 div 0465 div_MV
  146.         66 bin 0466 bin_NG
  147.         67 ful 0467 ful_NG
  148.         68 ha 0468 ha_NG
  149.         69 nic 0469 nic_NG
  150.         6a yo 046a yo_NG
  151.         70 ibo 0470 ibo_NG
  152.         71 kau 0471 kau_NG
  153.         72 om 0472 om_ET
  154.         73 ti 0473 ti_ET
  155.         74 gn 0474 gn_PY
  156.         75 cpe 0475 cpe_US
  157.         76 la 0476 la_VA
  158.         77 so 0477 so_SO
  159.         78 sit 0478 sit_CN
  160.         79 pap 0479 pap_AN
  161.     }
  162. }
  163.  
  164. # msgcat::mc --
  165. #
  166. #    Find the translation for the given string based on the current
  167. #    locale setting. Check the local namespace first, then look in each
  168. #    parent namespace until the source is found.  If additional args are
  169. #    specified, use the format command to work them into the traslated
  170. #    string.
  171. #
  172. # Arguments:
  173. #    src    The string to translate.
  174. #    args    Args to pass to the format command
  175. #
  176. # Results:
  177. #    Returns the translatd string.  Propagates errors thrown by the 
  178. #    format command.
  179.  
  180. proc msgcat::mc {src args} {
  181.     # Check for the src in each namespace starting from the local and
  182.     # ending in the global.
  183.  
  184.     variable Msgs
  185.     variable Loclist
  186.     variable Locale
  187.  
  188.     set ns [uplevel 1 [list ::namespace current]]
  189.     
  190.     while {$ns != ""} {
  191.     foreach loc $Loclist {
  192.         if {[info exists Msgs($loc,$ns,$src)]} {
  193.         if {[llength $args] == 0} {
  194.             return $Msgs($loc,$ns,$src)
  195.         } else {
  196.             return [uplevel 1 \
  197.                 [linsert $args 0 ::format $Msgs($loc,$ns,$src)]]
  198.         }
  199.         }
  200.     }
  201.     set ns [namespace parent $ns]
  202.     }
  203.     # we have not found the translation
  204.     return [uplevel 1 \
  205.         [linsert $args 0 [::namespace origin mcunknown] $Locale $src]]
  206. }
  207.  
  208. # msgcat::mclocale --
  209. #
  210. #    Query or set the current locale.
  211. #
  212. # Arguments:
  213. #    newLocale    (Optional) The new locale string. Locale strings
  214. #            should be composed of one or more sublocale parts
  215. #            separated by underscores (e.g. en_US).
  216. #
  217. # Results:
  218. #    Returns the current locale.
  219.  
  220. proc msgcat::mclocale {args} {
  221.     variable Loclist
  222.     variable Locale
  223.     set len [llength $args]
  224.  
  225.     if {$len > 1} {
  226.     error {wrong # args: should be "mclocale ?newLocale?"}
  227.     }
  228.  
  229.     if {$len == 1} {
  230.     set Locale [string tolower [lindex $args 0]]
  231.     set Loclist {}
  232.     set word ""
  233.     foreach part [split $Locale _] {
  234.         set word [string trimleft "${word}_${part}" _]
  235.         set Loclist [linsert $Loclist 0 $word]
  236.     }
  237.     }
  238.     return $Locale
  239. }
  240.  
  241. # msgcat::mcpreferences --
  242. #
  243. #    Fetch the list of locales used to look up strings, ordered from
  244. #    most preferred to least preferred.
  245. #
  246. # Arguments:
  247. #    None.
  248. #
  249. # Results:
  250. #    Returns an ordered list of the locales preferred by the user.
  251.  
  252. proc msgcat::mcpreferences {} {
  253.     variable Loclist
  254.     return $Loclist
  255. }
  256.  
  257. # msgcat::mcload --
  258. #
  259. #    Attempt to load message catalogs for each locale in the
  260. #    preference list from the specified directory.
  261. #
  262. # Arguments:
  263. #    langdir        The directory to search.
  264. #
  265. # Results:
  266. #    Returns the number of message catalogs that were loaded.
  267.  
  268. proc msgcat::mcload {langdir} {
  269.     set x 0
  270.     foreach p [mcpreferences] {
  271.     set langfile [file join $langdir $p.msg]
  272.     if {[file exists $langfile]} {
  273.         incr x
  274.         set fid [open $langfile "r"]
  275.         fconfigure $fid -encoding utf-8
  276.             uplevel 1 [read $fid]
  277.         close $fid
  278.     }
  279.     }
  280.     return $x
  281. }
  282.  
  283. # msgcat::mcset --
  284. #
  285. #    Set the translation for a given string in a specified locale.
  286. #
  287. # Arguments:
  288. #    locale        The locale to use.
  289. #    src        The source string.
  290. #    dest        (Optional) The translated string.  If omitted,
  291. #            the source string is used.
  292. #
  293. # Results:
  294. #    Returns the new locale.
  295.  
  296. proc msgcat::mcset {locale src {dest ""}} {
  297.     variable Msgs
  298.     if {[llength [info level 0]] == 3} { ;# dest not specified
  299.         set dest $src
  300.     }
  301.  
  302.     set ns [uplevel 1 [list ::namespace current]]
  303.  
  304.     set Msgs([string tolower $locale],$ns,$src) $dest
  305.     return $dest
  306. }
  307.  
  308. # msgcat::mcmset --
  309. #
  310. #    Set the translation for multiple strings in a specified locale.
  311. #
  312. # Arguments:
  313. #    locale        The locale to use.
  314. #    pairs        One or more src/dest pairs (must be even length)
  315. #
  316. # Results:
  317. #    Returns the number of pairs processed
  318.  
  319. proc msgcat::mcmset {locale pairs } {
  320.     variable Msgs
  321.  
  322.     set length [llength $pairs]
  323.     if {$length % 2} {
  324.     error {bad translation list: should be "mcmset locale {src dest ...}"}
  325.     }
  326.     
  327.     set locale [string tolower $locale]
  328.     set ns [uplevel 1 [list ::namespace current]]
  329.     
  330.     foreach {src dest} $pairs {
  331.         set Msgs($locale,$ns,$src) $dest
  332.     }
  333.     
  334.     return $length
  335. }
  336.  
  337. # msgcat::mcunknown --
  338. #
  339. #    This routine is called by msgcat::mc if a translation cannot
  340. #    be found for a string.  This routine is intended to be replaced
  341. #    by an application specific routine for error reporting
  342. #    purposes.  The default behavior is to return the source string.  
  343. #    If additional args are specified, the format command will be used
  344. #    to work them into the traslated string.
  345. #
  346. # Arguments:
  347. #    locale        The current locale.
  348. #    src        The string to be translated.
  349. #    args        Args to pass to the format command
  350. #
  351. # Results:
  352. #    Returns the translated value.
  353.  
  354. proc msgcat::mcunknown {locale src args} {
  355.     if {[llength $args]} {
  356.     return [uplevel 1 [linsert $args 0 ::format $src]]
  357.     } else {
  358.     return $src
  359.     }
  360. }
  361.  
  362. # msgcat::mcmax --
  363. #
  364. #    Calculates the maximun length of the translated strings of the given 
  365. #    list.
  366. #
  367. # Arguments:
  368. #    args    strings to translate.
  369. #
  370. # Results:
  371. #    Returns the length of the longest translated string.
  372.  
  373. proc msgcat::mcmax {args} {
  374.     set max 0
  375.     foreach string $args {
  376.     set translated [uplevel 1 [list [namespace origin mc] $string]]
  377.         set len [string length $translated]
  378.         if {$len>$max} {
  379.             set max $len
  380.         }
  381.     }
  382.     return $max
  383. }
  384.  
  385. # Convert the locale values stored in environment variables to a form
  386. # suitable for passing to [mclocale]
  387. proc msgcat::ConvertLocale {value} {
  388.     # Assume $value is of form: $language[_$territory][.$codeset][@modifier]
  389.     # Convert to form: $language[_$territory][_$modifier]
  390.     #
  391.     # Comment out expanded RE version -- bugs alleged
  392.     # regexp -expanded {
  393.     #    ^        # Match all the way to the beginning
  394.     #    ([^_.@]*)    # Match "lanugage"; ends with _, ., or @
  395.     #    (_([^.@]*))?    # Match (optional) "territory"; starts with _
  396.     #    ([.]([^@]*))?    # Match (optional) "codeset"; starts with .
  397.     #    (@(.*))?    # Match (optional) "modifier"; starts with @
  398.     #    $        # Match all the way to the end
  399.     # } $value -> language _ territory _ codeset _ modifier
  400.     if {![regexp {^([^_.@]+)(_([^.@]*))?([.]([^@]*))?(@(.*))?$} $value \
  401.         -> language _ territory _ codeset _ modifier]} {
  402.     return -code error "invalid locale '$value': empty language part"
  403.     }
  404.     set ret $language
  405.     if {[string length $territory]} {
  406.     append ret _$territory
  407.     }
  408.     if {[string length $modifier]} {
  409.     append ret _$modifier
  410.     }
  411.     return $ret
  412. }
  413.  
  414. # Initialize the default locale
  415. proc msgcat::Init {} {
  416.     #
  417.     # set default locale, try to get from environment
  418.     #
  419.     foreach varName {LC_ALL LC_MESSAGES LANG} {
  420.     if {[info exists ::env($varName)] 
  421.         && ![string equal "" $::env($varName)]} {
  422.         if {![catch {mclocale [ConvertLocale $::env($varName)]}]} {
  423.         return
  424.         }
  425.     }
  426.     }
  427.     #
  428.     # The rest of this routine is special processing for Windows;
  429.     # all other platforms, get out now.
  430.     #
  431.     if { ![string equal $::tcl_platform(platform) windows] } {
  432.     mclocale C
  433.     return
  434.     }
  435.     #
  436.     # On Windows, try to set locale depending on registry settings,
  437.     # or fall back on locale of "C".  
  438.     #
  439.     set key {HKEY_CURRENT_USER\Control Panel\International}
  440.     if {[catch {package require registry}] \
  441.         || [catch {registry get $key "locale"} locale]} {
  442.         mclocale C
  443.     return
  444.     }
  445.     #
  446.     # Keep trying to match against smaller and smaller suffixes
  447.     # of the registry value, since the latter hexadigits appear
  448.     # to determine general language and earlier hexadigits determine
  449.     # more precise information, such as territory.  For example,
  450.     #     0409 - English - United States
  451.     #     0809 - English - United Kingdom
  452.     # Add more translations to the WinRegToISO639 array above.
  453.     #
  454.     variable WinRegToISO639
  455.     set locale [string tolower $locale]
  456.     while {[string length $locale]} {
  457.         if {![catch {mclocale [ConvertLocale $WinRegToISO639($locale)]}]} {
  458.         return
  459.     }
  460.     set locale [string range $locale 1 end]
  461.     }
  462.     #
  463.     # No translation known.  Fall back on "C" locale
  464.     #
  465.     mclocale C
  466. }
  467. msgcat::Init
  468.